*
* $Id$
*
* $Log: gstrac.F,v $
* Revision 1.1.1.1  2002/07/24 15:56:26  rdm
* initial import into CVS
*
* Revision 1.1.1.1  2002/06/16 15:18:41  hristov
* Separate distribution  of Geant3
*
* Revision 1.1.1.1  1999/05/18 15:55:21  fca
* AliRoot sources
*
* Revision 1.2  1996/02/27 10:30:56  ravndal
* Correct interaction length for heavy ions
*
* Revision 1.1.1.1  1995/10/24 10:21:43  cernlib
* Geant
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/04 13/12/94  15.23.45  by  S.Giani
*-- Author :
      SUBROUTINE GSTRAC
C.
C.    ******************************************************************
C.    *                                                                *
C.    *       SUBR. GSTRAC                                             *
C.    *                                                                *
C.    *  Stores in stack JTRACK the information for current track      *
C.    *   segment at exit of current Volume/Medium.                    *
C.    *                                                                *
C.    *   Called by : GTRACK                                           *
C.    *   Authors   : S.Banerjee, F.Bruyant                            *
C.    *                                                                *
C.    ******************************************************************
C.
#include "geant321/gcbank.inc"
#include "geant321/gckine.inc"
#include "geant321/gcnum.inc"
#include "geant321/gcphys.inc"
#include "geant321/gcstak.inc"
#include "geant321/gctrak.inc"
#include "geant321/gcunit.inc"
#include "geant321/gcvolu.inc"
      REAL      XC(3)
C.
C.    ------------------------------------------------------------------
*
* *** Find where in the tracking skeleton to enter the current track
*
      IF (NLEVIN.EQ.NLEVEL) THEN
*       (case when GINVOL has not been called)
         JVO = LQ(JVOLUM-LVOLUM(NLEVIN))
         IF (INGOTO.GT.0) THEN
*
*  **      Point is in content predicted by GTNEXT, go one level down
*
            NLEVIN = NLEVIN +1
            INFROM = 0
            JIN    = LQ(JVO-INGOTO)
            IVOT   = Q(JIN+2)
            LVOLUM(NLEVIN) = IVOT
            LINDEX(NLEVIN) = INGOTO
            LINMX (NLEVIN) = Q(JVO+3)
*
*  **      Prepare the translation and rotation matrices if necessary
*
            JSKL = LQ(JSKLT-NLEVIN)
            IF (NLEVIN.GT.2) THEN
               IOFF = IQ(JSKL-3)
               DO 29 ILEV = 1, NLEVEL
                  IF (IQ(JSKL+IOFF+ILEV).NE.LINDEX(ILEV)) GO TO 30
   29          CONTINUE
            ENDIF
            JSK  = LQ(JSKL-INGOTO)
            IF (IQ(JSK+1).GT.0) GO TO 100
   30       IROTT = Q(JIN+4)
            CALL GTRMUL (GTRAN(1,NLEVEL), GRMAT(1,NLEVEL), Q(JIN+5),
     +                   IROTT, GTRAN(1,NLEVIN), GRMAT(1,NLEVIN))
            GO TO 100
         ELSE
*
*  **      otherwise, go one level up
*
            NLEVIN = NLEVIN -1
*
         ENDIF
*
      ELSE IF (NLEVIN.GT.NLEVEL) THEN
         INFROM = 0
         GO TO 100
*
      ELSE IF (NLEVIN.LT.0) THEN
*       (case when entering a dominant overlaping volume)
         NLEVIN = -NLEVIN
         INFROM = LINDEX(NLEVIN+1)
         GO TO 100
      ENDIF
*
*  **  Track has left current volume, check levels up
*
   80 IF (NLEVIN.EQ.0) GO TO 999
*
      IF (GRMAT(10,NLEVIN).EQ.0.) THEN
         DO 88 I = 1,3
            XC(I) = VECT(I) -GTRAN(I,NLEVIN)
   88    CONTINUE
      ELSE
C       (later, code in line)
         CALL GTRNSF (VECT, GTRAN(1,NLEVIN), GRMAT(1,NLEVIN), XC)
      ENDIF
*
      JVO  = LQ(JVOLUM-LVOLUM(NLEVIN))
      JPAR = LQ(JGPAR-NLEVIN)
      CALL GINME (XC, Q(JVO+2), Q(JPAR+1), IYES)
      IF (IYES.NE.0) THEN
         INFROM = LINDEX(NLEVIN+1)
      ELSE
         NLEVIN = NLEVIN -1
         GO TO 80
      ENDIF
*
* *** Allocate last 'garbaged' area if any, otherwise first 'free' one
*
  100 IF (NJGARB.NE.0) THEN
         NCUR   = NJGARB
         LCUR   = JTRACK +(NCUR-1)*NWTRAC
         NJGARB = IQ(LCUR+1)
      ELSE
         NCUR   = NJFREE
         LCUR   = JTRACK +(NCUR-1)*NWTRAC
         NJFREE = NCUR +1
      ENDIF
*
* *** Link allocated area to relevant chain in JSKLT structure
*
      JSKL = LQ(JSKLT-NLEVIN)
      IQ(LCUR+1) = IQ(JSKL+LINDEX(NLEVIN))
      IQ(JSKL+LINDEX(NLEVIN)) = NCUR
*
* *** Store information for current track segment in stack JTRACK
*
      IQ(LCUR+2) = 0
      IQ(LCUR+3) = NTMULT
      IQ(LCUR+4) = ITRA
      IQ(LCUR+5) = ISTAK
      IQ(LCUR+6) = IPART
      IQ(LCUR+7) = NSTEP
*free IQ(LCUR+8) = IDECAD
      IQ(LCUR+9) = IEKBIN
      IQ(LCUR+10)= ISTORY
      IQ(LCUR+11)= INFROM
*
      IPCUR = LCUR +NWINT
      DO 109 I = 1,7
         Q(IPCUR+I)  = VECT(I)
  109 CONTINUE
      Q(IPCUR+8)  = GEKIN
      Q(IPCUR+9)  = SLENG
      Q(IPCUR+10) = GEKRAT
      Q(IPCUR+11) = TOFG
      Q(IPCUR+12) = UPWGHT
*
      IPCUR = IPCUR +NWREAL
      IF (ITRTYP.EQ.1) THEN
*     Photons
         Q(IPCUR+1) = ZINTPA
         Q(IPCUR+2) = ZINTCO
         Q(IPCUR+3) = ZINTPH
         Q(IPCUR+4) = ZINTPF
         Q(IPCUR+5) = ZINTRA
      ELSE IF (ITRTYP.EQ.2) THEN
*     Electrons
         Q(IPCUR+1) = ZINTBR
         Q(IPCUR+2) = ZINTDR
         Q(IPCUR+3) = ZINTAN
      ELSE IF (ITRTYP.EQ.3) THEN
*     Neutral hadrons
         Q(IPCUR+1) = SUMLIF
         Q(IPCUR+2) = ZINTHA
      ELSE IF (ITRTYP.EQ.4) THEN
*     Charged hadrons
         Q(IPCUR+1) = SUMLIF
         Q(IPCUR+2) = ZINTHA
         Q(IPCUR+3) = ZINTDR
      ELSE IF (ITRTYP.EQ.5) THEN
*     Muons
         Q(IPCUR+1) = SUMLIF
         Q(IPCUR+2) = ZINTBR
         Q(IPCUR+3) = ZINTPA
         Q(IPCUR+4) = ZINTDR
         Q(IPCUR+5) = ZINTMU
      ELSE IF (ITRTYP.EQ.7) THEN
*     Cerenkov photons
         Q(IPCUR+1) = ZINTLA
      ELSE IF (ITRTYP.EQ.8) THEN
*     Ions
         Q(IPCUR+1) = ZINTHA
         Q(IPCUR+2) = ZINTDR
      ENDIF
*
* *** Take care of the skeleton
*
      IF (NLEVIN.GT.NLDOWN) THEN
         NLDOWN = NLEVIN
         JSKL   = LQ(JSKLT-NLDOWN)
*
*  **    Clear skeleton at lowest level if necessary
*
         JOFF   = JSKL + IQ(JSKL-3)
         DO 229 ILEV = 1, NLDOWN-1
            IF (IQ(JOFF+ILEV).EQ.LINDEX(ILEV)) GO TO 229
            NINSK = LINMX(NLDOWN)
            DO 209 IN = 1, NINSK
               JSK  = LQ(JSKL-IN)
               IQ(JSK+1) = 0
  209       CONTINUE
            DO 219 I = ILEV, NLDOWN-1
               IQ(JOFF+I) = LINDEX(I)
  219       CONTINUE
            GO TO 230
  229    CONTINUE
      ENDIF
*
*  ** Fill up the skeleton at NLDOWN
*
  230 IF (NLEVIN.GT.NLEVEL) THEN
         JSKL = LQ(JSKLT-NLDOWN)
         JSK  = LQ(JSKL-LINDEX(NLDOWN))
         IF (IQ(JSK+1).LE.0) THEN
            LQ(JSK-1) = LQ(JGPAR-NLDOWN)
            IQ(JSK+1) = IQ(JGPAR+NLDOWN)
            IQ(JSK+2) = LVOLUM(NLDOWN)
            DO 239 I = 1, 3
               Q(JSK+2+I) = GTRAN(I,NLDOWN)
  239       CONTINUE
            DO 249 I = 1, 10
               Q(JSK+5+I) = GRMAT(I,NLDOWN)
  249       CONTINUE
         ENDIF
*
      ENDIF
*
* *** Update NALIVE and test if tracking stack is full
*
      NALIVE = NALIVE + 1
      IF (NALIVE-IQ(JSTAK+1).GE.NJTMAX) THEN
         WRITE (CHMAIL, 1001)
         CALL GMAIL (0, 0)
         NJTMAX = -NJTMAX
         NLVSAV = NLEVEL
         DO 309 I = 2,NLDOWN
            LINSAV(I) = LINDEX(I)
            LMXSAV(I) = LINMX(I)
  309    CONTINUE
      ENDIF
*
 1001 FORMAT (' GSTRAC : Stack JTRACK full. Inhibit parallel tracking')
*                                                             END GSTRAC
  999 END
 
